home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 2 / Gold Medal Software Volume 2 (Gold Medal) (1994).iso / os2 / forth038.arj / FORTH.INI < prev    next >
Text File  |  1994-01-20  |  15KB  |  444 lines
  1. ( FORTH.INI  Initialization file for FORTH/2        10/14/93 )
  2. ( Copyright <c> 1993,1994  BLUE STAR SYSTEMS )
  3.  
  4. ( The following words from the Forth-83 standard are still missing:
  5.  
  6.   >BODY  CONVERT
  7.   D+  D<  DNEGATE  UM*  UM/MOD
  8.  
  9.   These are partially supported in the file BLOCKS.4TH:
  10.      BLK  BLOCK  BUFFER  FLUSH  LOAD  SAVE-BUFFERS  UPDATE
  11. )
  12.  
  13. DECIMAL
  14.  
  15.  
  16. : greet ." This message came from the file 'FORTH.INI' " cr ;
  17. : CLS   27 emit ." [2J"  0 #OUT ! ;
  18.  
  19. ( Define the NON-STANDARD!!! "   Fixed 7/8/93 v0.031 )
  20. : " POSTPONE S"
  21.     POSTPONE DROP
  22.     POSTPONE CELL
  23.     POSTPONE -  ; IMMEDIATE
  24.  
  25. VARIABLE CSP       ( Adds stack checking during compilation )
  26. (
  27.   : !CSP   SP@ CSP ! ;
  28.   : ?CSP   SP@ CSP @ - IF ." Definition not finished " ABORT THEN ;
  29.   : :                     :        !CSP ;  IMMEDIATE
  30.   : :NONAME               :NONAME  !CSP ;  IMMEDIATE
  31.   : ;      ?CSP  POSTPONE ;  ;       IMMEDIATE
  32. )
  33.  
  34.  
  35. 1 CELLS CONSTANT CELL
  36.  
  37.  
  38. 32 CONSTANT BL
  39. : SPACE    BL EMIT ;
  40. : SPACES   0 MAX  1000 MIN  0 FOR  SPACE  NEXT ;
  41.  
  42. HEX
  43. : ?BRANCH,  C383038B , 0FC02304 , 84 C, 0 , ;
  44. : BRANCH,   E9 C, 0 , ;
  45.  
  46. : BEGIN     HERE ;             IMMEDIATE
  47. : WHILE     ?BRANCH,  HERE ;   IMMEDIATE
  48.  
  49. : REPEAT    SWAP   BRANCH,  HERE -  HERE CELL - !
  50.                        HERE OVER -  SWAP CELL - ! ;   IMMEDIATE
  51. : UNTIL           ?BRANCH,  HERE -  HERE CELL - ! ;   IMMEDIATE
  52. : AGAIN            BRANCH,  HERE -  HERE CELL - ! ;   IMMEDIATE
  53. : EXIT      R> DROP ;
  54.  
  55.  
  56. 0 CONSTANT CASE  IMMEDIATE
  57. : <OF>      OVER = IF  DROP 1  ELSE  0  THEN ;
  58. : OF        1+ >R  POSTPONE OVER   POSTPONE =
  59.                    POSTPONE IF     POSTPONE DROP  R> ; IMMEDIATE
  60. : ENDOF         >R POSTPONE ELSE                  R> ; IMMEDIATE
  61. : ENDCASE          POSTPONE DROP
  62.             0 FOR  POSTPONE THEN  NEXT ;               IMMEDIATE
  63.  
  64.  
  65. : LIT     R> DUP CELL + >R @ ;
  66. : ASCII   ( char-- b )  POSTPONE [CHAR] ;              IMMEDIATE
  67. : CONTROL ( char-- b )  BL WORD  CELL+ C@ 64 -
  68.                         State @ IF  POSTPONE LIT ,  THEN ; IMMEDIATE
  69.  
  70. \ : CHAR    POSTPONE ASCII ; IMMEDIATE
  71.  
  72. DECIMAL
  73. : PAD   HERE 200 + ;      VARIABLE HLD
  74. : <#     ( n -- n )  PAD HLD ! ;
  75.  
  76. : #9     ( n -- )  9 OVER <  IF  7 +  THEN   ASCII 0 + ;
  77. : HOLD   ( char -- )  HLD @ -1 +  DUP HLD !  C! ;
  78.  
  79. : SIGN   0 < IF  ASCII - HOLD  THEN ;
  80.  
  81. : #   ( n -- n  ( one digit )  BASE @  /MOD ( U/MOD ) SWAP ABS #9 HOLD ;
  82. : #S  ( n -- 0  )  BEGIN  #   DUP  0 = UNTIL ;
  83.  
  84. : #>  ( n -- a l )  DROP   HLD @   PAD OVER -  ;
  85.  
  86. : .R  ( n length -- ) >R  DUP ABS  <#  #S  SWAP SIGN  #>
  87.                       R>  OVER - SPACES  TYPE ;
  88. : U.R ( n length -- ) >R           <#  #S  #>
  89.                       R>  OVER - SPACES  TYPE ;
  90. : .   0 .R  SPACE ;
  91. : ?   @ . ;
  92.  
  93. : ANSI. ( n -- )   ABS 0 .R ;
  94. : XY    ( x y -- ) 27 EMIT ." ["  ANSI.  59 EMIT  ANSI.  72 EMIT ;
  95.  
  96. : -ROT    ( n1 n2 n3 -- n3 n1 n2 ) ROT ROT ;
  97. : UNDER   ( n1 n2 -- n1 n1 n2 ) >R DUP R> ;
  98. : TUCK    ( n1 n2 -- n2 n1 n2 ) SWAP OVER ;
  99. : ALONG   ( n1 n2 -- n1+n2 n1 ) OVER + SWAP ;  ( good before DO loops )
  100.  
  101. : W-  CELL - ;   : 0>  0 > ;
  102. : 2+  2 + ;      : 2-  2 - ;
  103.  
  104. : TOGGLE ( n addr -- )  TUCK @ XOR SWAP ! ;
  105.  
  106. : TRUE  -1 ;                        : FALSE  0 ;
  107. : ON ( addr -- )  -1 SWAP ! ;       : OFF ( addr -- )  0 SWAP ! ;
  108.  
  109. : -TRAILING   ( addr n1 -- addr n2 )  2DUP + 1-  SWAP
  110.               0 FOR   DUP C@  BL > IF  LEAVE  ELSE  1-  THEN
  111.                 NEXT  1+  OVER - ;
  112. : 0-Terminate ( addr -- )  @+ + 0 SWAP C! ;
  113. : 0"COUNT ( addr -- addr len )  DUP    BEGIN
  114.                       DUP C@ WHILE  1+ REPEAT  OVER - ;
  115.  
  116.  
  117. : ".  ( addr -- )  @+ TYPE ;      (  ".  prints a counted       string )
  118. : 0". ( addr -- )  0"COUNT TYPE ; ( 0".  prints a 0-terminated string. )
  119.  
  120.  
  121. 4 CONSTANT StrPadSize                   ( All strings are padded with 4 0's  )
  122. : "->0"    ( addr1 -- addr2 ) CELL + ;  ( Convert counted string to 0-end string )
  123. : ",       @ CELL+ StrPadSize + ALLOT ; ( Compile string into dictionary   )
  124.  
  125. : <">      R> DUP  @+ +  StrPadSize +  >R     ;
  126. : <.(>     R> DUP  @+ +  StrPadSize +  >R  ". ;
  127. : <ABORT"> R> DUP  @+ +  StrPadSize +  >R  SWAP  IF  ".  ABORT CR
  128.            ELSE  DROP  THEN ;
  129.  
  130. \ HUH? (MAW - I don't get this one!?!?!?!? )
  131. \
  132. \  : 0"       State @ IF  POSTPONE <0">   THEN
  133. \             ASCII " WORD
  134. \             State @ IF  ",  ELSE "->0" THEN ; IMMEDIATE
  135. \
  136. \ : "        State @ IF  POSTPONE <">    THEN
  137. \            ASCII " WORD
  138. \            State @ IF  ",             THEN ; IMMEDIATE
  139. \
  140. \ : ."       State @ IF  POSTPONE ."    ELSE
  141. \            ASCII " WORD  ".           THEN ; IMMEDIATE
  142. \
  143. \ : .(       State @ IF  POSTPONE <.(>   THEN
  144. \            ASCII ) WORD
  145. \            State @ IF  ",  ELSE  ".   THEN ; IMMEDIATE
  146. \
  147. \ : S"       POSTPONE "  POSTPONE @+ ;
  148. \
  149. \ : ,"       POSTPONE "  HERE @ CELL+ ALLOT ;
  150. \
  151.  
  152. : ABORT"   ?COMPILE    POSTPONE <ABORT"> 
  153.            ASCII " WORD  ", ; IMMEDIATE
  154.  
  155. VARIABLE FENCE
  156. : +VLink      CELL+ ;
  157. : +NextVoc  2 CELLS + ;
  158. : FORGET ( name-- )     \ Forgets across vocabularies
  159.      '  FENCE @ over U< IF
  160.        Context ContextSize CELLS along DO
  161.            dup  I @  u< IF  0 I !  THEN  CELL +LOOP
  162.        Context  Context ContextSize CELLS along do
  163.            I @ IF  I @  0 I !  over !  CELL+  THEN   CELL +LOOP  drop
  164.        >R  I  Current @ +VLink @ U< IF  POSTPONE Forth  THEN
  165.        VOC-LINK @
  166.        BEGIN  I OVER U< WHILE  +NextVoc @  REPEAT
  167.        DUP VOC-LINK !
  168.        BEGIN  DUP +VLink
  169.            BEGIN  @  dup I u< UNTIL
  170.            over +VLink !  +NextVoc @  ?DUP 0=
  171.        UNTIL  R> DP!
  172.     ELSE
  173.       ." Can't forget before FENCE! " cr
  174.     THEN ;
  175.  
  176. ' FORGET FENCE !   \ Set up the fence
  177.  
  178.  
  179.  
  180. : 2CONSTANT  CREATE  SWAP , ,  DOES>  DUP @ SWAP CELL+ @ ;
  181. : 2VARIABLE  VARIABLE  CELL ALLOT ;
  182.  
  183. : ERASE  ( addr len -- )  0 FILL ;  \ Fill memory with 0's
  184.  
  185. : TYPE     dup 20000 > ABORT" Tried to TYPE over 20000 characters" TYPE ;
  186.  
  187. \ "MOVE  moves a counted string to another address
  188.  
  189. : "MOVE  ( counted_string_address dest_address -- )
  190.          OVER @  CELL+  CMOVE ;
  191.  
  192.  
  193. \ MOVE>"  copies addr,len to be a counted string at dest_addr
  194.  
  195. : MOVE>"  ( addr len dest_addr -- ) 2dup !
  196.                                     CELL+ swap cmove ;
  197.  
  198.  
  199. \ "CAT   conCATenate string1 to the end of string2
  200.  
  201. : "CAT   ( counted_string_addr1  counted_string_dest_addr2 -- )
  202.          2DUP  @+ +  SWAP @+ ROT SWAP CMOVE
  203.          SWAP @  SWAP +! ;
  204.  
  205.  
  206. : "CONSTANT  ( addr <word>-- Does: -- addr ) HERE 53 + "MOVE
  207.              CREATE  HERE ",  DOES> ;
  208.  
  209. : CALL"  ( <string><name>-- Does: -- addr ) ASCII " WORD  "CONSTANT ;
  210.  
  211. \ CALL" Bill Clinton" President  ...   President ".
  212.  
  213.  
  214. : INTEGER  ( -- )   CREATE  HERE  0 ,
  215.                             %TO @ IF  <TODOES>  ELSE  DROP  THEN
  216.                     DOES>   <TODOES> ;
  217.  
  218. : INTARRAY ( size ) CREATE  CELLS  HERE  OVER ALLOT  DUP ROT 0 FILL
  219.                             %TO @ IF  SWAP CELLS + <TODOES>  THEN
  220.                     DOES>  SWAP CELLS +  <TODOES> ;
  221.  
  222. \ STRING TO variables:  " XYZ123" TO String1  ...   String1 ".
  223.  
  224. variable StringSize  255 StringSize !    \ Size of STRING's to be created
  225. variable TempString  StringSize @ ALLOT  \ To move string out of way of CREATE
  226.  
  227. : <"TODOES>  ( -- addr  ;  addr TO --   ;  addr +TO --  )
  228.              %TO @    IF
  229.              %TO @ 0> IF  "MOVE  ELSE  "CAT  THEN  0 %TO !  THEN ;
  230.  
  231. : STRING   %TO @ IF  TempString "MOVE  TempString  THEN
  232.            CREATE  HERE  StringSize @ CELL+ ALLOT  DUP StringSize @ CELL+ 0 FILL
  233.                    %TO @ IF  <"TODOES>  ELSE  DROP  THEN
  234.            DOES>   <"TODOES> ;
  235.  
  236.  
  237. : TONE ( frequency duration -- ) SWAP SYS$BEEP SYSCALL  3 DROPS ;
  238. ( frequency in cycles/second, duration in milliseconds, 1/1000 of a second )
  239.  
  240. : BEEP  3000 60 TONE ;
  241.  
  242. HEX
  243.  
  244. Variable   Handle               0 Handle !
  245. Variable   ActionTaken
  246. Variable   BytesTransferred
  247. Variable   BufferArea
  248. Variable   BufferLength
  249. Variable   LineSource
  250. Variable   LineLength
  251.  
  252. 0   Constant    EABUF
  253. 42  Constant    OpenMode
  254. 11  Constant    OpenFlag
  255. 0   Constant    FileAttribute
  256. 0   Constant    FileSize
  257.  
  258. : Source-ID Handle @ ;
  259.  
  260. : \ Source-ID 0= IF Postpone \ ELSE
  261.                     0 #TIB !   THEN ; Immediate
  262.  
  263. : Source LineLength @ LineSource @ ;
  264.  
  265. : Open ( name -- handle ) >R EABUF OpenMode OpenFlag FileAttribute
  266.     FileSize ActionTaken Handle R> sys$open syscall
  267.     9 Drops  handle @ ;
  268.  
  269. : Close ( handle -- ) Sys$Close SysCall 2drop ;
  270.  
  271. : FWrite ( handle address length )
  272.   BufferLength !
  273.   BufferArea !
  274.   Handle !
  275.   BytesTransferred BufferLength @ BufferArea @ Handle @ sys$write syscall
  276.   5 drops ;
  277.  
  278. : FRead ( handle address buffersize --  )
  279.   BufferLength !
  280.   BufferArea !
  281.   Handle !
  282.   BytesTransferred BufferLength @ BufferArea @ Handle @ sys$read syscall
  283.   5 drops ;
  284.  
  285. : EOF?  ( -- f ) BytesTransferred @ 0= ;  \ True if at end of file
  286.  
  287. Variable FilePtr
  288. : FSeek   ( ptr handle -- f ) >R  FilePtr  0  ROT   R> SYS$SEEK SYSCALL
  289.                               >R  4 Drops  R> ;
  290.  
  291. ( Increased line length from 100 to 200  11/14/93 MAW )
  292. (                                               vvv   )
  293.  
  294. : Readln ( handle -- addr len ) DUP >R  FBuffer 200 FRead
  295.          FBuffer  begin
  296.                      dup c@  dup 0A =  swap 0= OR  NOT while
  297.               1+  repeat  1- ( subtract off 0Dh from length )
  298.          FBuffer tuck -  dup FilePtr @ + 2+ R> FSeek  ABORT" Seek failed"
  299.  
  300.          2dup LineSource ! LineLength ! ;
  301.  
  302.  
  303. : Fibinacci ( n -- fib[n] )
  304.   dup 2 <= if drop 1 else dup 1 - recurse swap 2 - recurse + then ;
  305.  
  306.  
  307. Variable ResultCodes 4 allot
  308.  
  309. Variable Arguments 256 Allot
  310.  
  311. : Args  ( string -- ) Arguments "MOVE  Arguments 0-Terminate ;
  312. : Args" ( args-- )  State @ IF  COMPILE "  Compile Args  ELSE
  313.                                   ASCII " WORD  Args     THEN ; IMMEDIATE
  314.  
  315. : Shell ( name -- ) Arguments CELL+ @ if
  316.                         Arguments CELL+  over @  over + 1+ Arguments @ 1+ cmove>
  317.                         dup @  Arguments + CELL+ 0 swap c!
  318.                         dup    Arguments "MOVE then     "->0"
  319.                     ResultCodes 0 Arguments CELL+ 0 0 0 sys$execpgm syscall
  320.                     8 drops     0 Arguments CELL+ ! ;
  321.  
  322. : Shell"   State @ IF   POSTPONE "  Compile Shell  ELSE
  323.                            ASCII " WORD  shell     THEN ;  IMMEDIATE
  324.  
  325. : CommandShell ( shell's to C:\OS2\CMD.EXE ) " C:\OS2\CMD.EXE" shell ;
  326.  
  327. : dir          " /C DIR " Arguments "MOVE  bl word Arguments "CAT
  328.                Arguments 0-terminate  CommandShell ;  
  329. \ Example: dir *.4th
  330.  
  331. : DoShell " c:\os2\cmd.exe" resultcodes 0 0 0 0 0 sys$execpgm syscall 8 drops ;
  332.  
  333. DECIMAL
  334.  
  335. \ ?PAGE gives scrolling control to pause at the end of each screen
  336.  
  337. VARIABLE L/P  23 L/P !  ( Lines per Page )
  338. : 0PAGE  0 LINE# ! ;
  339. : ?PAGE  ( -- f )  1 LINE# +!  LINE# @ L/P @ > IF
  340.             CR  ." Space to continue, Enter to advance 1 line... "
  341.             KEY  255 AND  DUP 32 OR 113 = if  DROP  CR True  else
  342.                                      31 > if  0PAGE  then   False then
  343.             13 EMIT  46 SPACES  13 EMIT  ELSE  CR  False  THEN ;
  344.  
  345.  
  346. \ Use DUMP to examine an area of memory 
  347. DECIMAL
  348. : HEX.     DUP 9 > IF  55  ELSE  48  THEN  + EMIT ;
  349. : SAFEMIT  DUP 14 < OVER 6 > AND IF DROP BL THEN  EMIT ;
  350. : ASCII. ( addr -- )  16 0 DO  DUP C@ SAFEMIT  1 + LOOP  DROP ;
  351. : BYTE.    DUP 16 / HEX. 16 MOD HEX. SPACE ;
  352. : LINE.  ( addr -- ) 16 0 DO  DUP C@ BYTE.  1 +
  353.                  DUP 16 MOD 0 = IF  SPACE  THEN  LOOP DROP ;
  354. : DUMP   ( addr len -- ) BASE @ >R HEX  0PAGE CR
  355.          16 / 1 +  0 DO
  356.                DUP .  SPACE  DUP LINE.  3 SPACES DUP ASCII.  
  357.                ?PAGE IF  LEAVE  THEN
  358.          16 + LOOP R> BASE !  DROP ;
  359.  
  360.  
  361. \ MORE lists the contents of a file.   Example:  0" FORTH.INI" MORE
  362. : MORE ( name -- )  Open  0PAGE  CR  0 FilePtr !
  363.         begin   dup readln type  ?PAGE
  364.                 eof?  OR  until
  365.         Close ;
  366.  
  367. : MORE" ( name-- ) ASCII " WORD  CELL+ MORE ;
  368. \ Example: MORE" FORTH.INI"
  369.  
  370. create WordStr 31 allot   variable ViewPtr
  371. : VIEW ( word-- )  0" FORTH2.DOC" Open  CR  0 FilePtr !
  372.         BL Word  WordStr "MOVE
  373.         ViewPtr @ IF  ViewPtr @ over FSEEK ABORT" Seek failed"
  374.         ELSE
  375.           870 0 do  dup readln 2drop       \ Skip 880 lines
  376.                     eof? if  leave then
  377.           loop      eof? if  exit  then
  378.           begin   dup readln               \ Look for vocabulary listing
  379.                   " --Begin--"  =STRING  eof? or  until
  380.           eof? ABORT" Did not find vocabulary listing"
  381.           FilePtr @ ViewPtr !              \ Save beginning location
  382.         THEN
  383.         begin   dup readln                 \ Look for word
  384.                2dup WordStr @ min  WordStr =STRING NOT
  385.                eof? NOT and  while  2drop
  386.         repeat
  387.         eof? ABORT" Did not find word"
  388.         TYPE  CR  close ;
  389. \ VIEW  shows information about Forth words:  VIEW ECHO
  390.  
  391.  
  392. \ User ECHO to turn on/off echoing of files while they are being loaded.
  393.  
  394. VARIABLE Echo  \ Echo ON  --> Echo file being loaded to screen
  395.                \ Echo OFF --> Do not echo
  396.  
  397. ( TRUE ECHO ! )
  398.  
  399. : INCLUDE ( name -- ) OPEN >R                \ Load a Forth source file
  400.         TIB @  FilePtr @  LINE# @  Echo @    \ save & restore TIB
  401.         0 FilePtr !  0 LINE# !
  402.         begin  i readln   1 LINE# +!
  403.            EOF? not while
  404.                dup if
  405.                   Echo @ if cr 2dup type ( 10 ms ) then
  406.                   1+ SPAN !  TIB ! 0 >IN ! INTERPRET
  407.                else  2drop  then
  408.            repeat    2drop
  409.         Echo !  LINE# !  FilePtr !  TIB !
  410.         R> Close
  411.   0 #TIB ! 0 >IN ! 0 Handle !
  412.   ;
  413.  
  414. : INCLUDE"  ( filename-- ) ASCII " WORD CELL+ INCLUDE ; \ INCLUDE" STRUCT.4TH"
  415.  
  416.  
  417. : VOCABULARY ( voc_name-- )
  418.              CREATE  HERE  0 ,  0 ,  VOC-LINK @ ,  VOC-LINK !  IMMEDIATE
  419.              DOES>   <VOCABULARY> ;
  420.  
  421. : DEFINITIONS ( -- )  CONTEXT @ CURRENT ! ;
  422. : ONLY ( -- ) CONTEXT @  CONTEXT ContextSize CELLS 0 FILL  CONTEXT !
  423.               DEFINITIONS ;
  424.  
  425. HEX
  426. : show ( -- ) dup 20 - dup 4 - @ ." {" type ." }" ;
  427. : MyExecute show key drop <execute> ;
  428.  
  429. ( Install the debugger - Comment out to save lot's o headaches )
  430. \ ' MyExecute 'Execute !
  431.  
  432. DECIMAL
  433.  
  434. ( Add any files you want to load at start-up time here )
  435.  
  436. ( include" struct.4th"   )
  437.   include" threads.4th"
  438. ( include" locals.4th"   )
  439. ( include" startup.4th"  )
  440.   include" mike.4th"
  441.  
  442. greet
  443.  
  444.